; TODO: non-working at the moment
;       test-generic.ss works, is this file old?
;       /soegaard 27 june 2005

;;; Automatic test generator


(require (lib "set.ss" "galore")
         (lib "galore-units.ss" "galore")
         (lib "unitsig.ss")
         (lib "list.ss"))

(define types
  '(
    ;(singleton    : elm         -> set)
    
    ;;(set          : elm ...     -> set)
    ;(set          : elm     -> set)
    
    ;(size         : set         -> integer)
    ;(elements     : set         -> (list elm))
    
    (union        : set set     -> set)
    (intersection : set set     -> set)
    (difference   : set set     -> set)
    
    ;(empty?       : set         -> boolean)
    
    ;(insert1      : elm set     -> set)
    
    ;(member?      : elm set     -> boolean)
    ;;(member       : elm set     -> (union elm #f))
    
    ;(subset?      : set set     -> boolean)
    ;(equal?       : set set     -> boolean)
    
    ;(insert       : set elm ... -> set)
    (insert       : set elm -> set)
    
    ; (remove       : set elm ... -> set)
    (remove       : set elm -> set)
    ;(remove1      : elm set     -> set)
    ))

(define (operations)
  (map car types))

(define (operation-member operation)
  (ormap (lambda (type) 
           (if (eq? (first type) operation) 
               type 
               #f))
         types))

; (operation-type 'insert) ==> (set elm ... -> set)
(define (operation-type operation)
  (let ((type (operation-member operation)))
    (when (not type) (error 'operation-type "no type associated with ~a" operation))
    (rest (rest type))))

; (before-arrow '(a b -> c))  ==> (a b)
(define (before-arrow type)
  (when (not (member '-> type)) (error 'before-arrow "no arrow in type: ~a" type))
  (do ((type   type (cdr type))
       (before '()  (cons (car type) before)))
    ((eq? (first type) '->)
     (reverse! before))))

; (after-arrow '(a b -> c))  ==>  c
(define (after-arrow type)
  (when (not (member '-> type)) (error 'after-arrow "no arrow in type: ~a" type))
  (first (rest (member '-> type))))

; (operation-result-type 'insert)  ==>  set
(define (operation-result-type operation)
  (let ((type (operation-member operation)))
    (when (not type) (error 'operation-result-type "unknown operation: ~a" operation))
    (after-arrow type)))

; (operation-argument-types 'insert) ==>  (set elm)
(define (operation-argument-types operation)
  (let ((type (operation-member operation)))
    (when (not type) (error 'operation-argument-types "unknown operation: ~a" operation))
    (rest (rest (before-arrow type)))))

; (operations/result-type 'boolean)  ==>  (empty? member? subset? equal?)
(define (operations/result-type type)
  (filter (lambda (op)
            (equal? (operation-result-type op) type))
          (operations)))

(define (build-base-level-expr type)
  (case type
    [(set) `(set ,(random 10) ,(random 10) ,(random 10))]
    [(elm) (random 10)]
    [else  (error 'build-base-level-expr "no base level exprs known for ~a" type)]))


(define (random-element-of l)
  (list-ref l (random (length l))))



(define (build-expr type level)
  (define (build-sub-expr type) (build-expr type (- level 1)))
  (cond
    [(or (= level 0)
         (empty? (operations/result-type type)))
     (build-base-level-expr type)]
    [else         
     (let* ((operation (random-element-of (operations/result-type type)))
            (arg-exprs (map build-sub-expr (operation-argument-types operation))))
       `(,operation ,@arg-exprs))]))


(define primitive:equal? equal?)

(define (unit->namespace set@)
  (use-set set@)
  (let ((n (make-namespace)))
    (parameterize ([current-namespace n])
      (namespace-set-variable-value! 'mergesort mergesort)
      (namespace-set-variable-value! 'set set)
      (namespace-set-variable-value! 'union union)
      (namespace-set-variable-value! 'intersection intersection)
      (namespace-set-variable-value! 'difference difference)
      (namespace-set-variable-value! 'insert insert)
      (namespace-set-variable-value! 'remove remove)
      (namespace-set-variable-value! 'elements elements))
    n))

(define (test expr namespaces)
  ; test whether expr evaluates to the same value in all namespaces
  (define (eval-expr expr namespace)
    (parameterize ([current-namespace namespace])
      (eval expr)))
  
  (printf "~a~n" expr)
  (let ((results (map (lambda (ns) (eval-expr expr ns))
                      namespaces)))
    (cond 
      [(not (andmap (lambda (r) (equal? (first results) r))
                    (rest results)))
       (error "FAILED:\n"
              expr "\n" results)]
      [else (printf "~a~n" results)])))



(define collision-integers@
  (unit/sig ordered^
    (import)
    (define (hash a) (- a (modulo a 3)))
    (define elm=   =)
    (define (elm<  a b) (< (hash a) (hash b)))
    (define (elm<= a b) (or (= a b) (elm< a b)))))

;;; TEST
(let* ([order      collision-integers@]
       [namespaces (map (lambda (set-unit)
                          (unit->namespace 
                           (instantiate-set set-unit order)))
                        (list 
                         ordered-list-set@ 
                         unbalanced-search-tree-set@ 
                         red-black-tree-set@ 
                         ;randomized-binary-search-tree-set@
                         ;weight-balanced-tree-set@
                         ))])
  (do ((i 0 (+ i 1)))
    ((= i 1000) (void))
    (test `(mergesort (elements ,(build-expr 'set (random 6))) <) namespaces)))

